; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; This is the main entry point to the compiler.  It returns a template
; that will execute the forms (each of which is a node).
;
; This is written in a somewhat odd fashion to make sure that the forms are
; not retained once they have been compiled.

(define (compile-forms forms name package-key)
  (with-package-key package-key
    (lambda ()
      (if (null? forms)
	  (segment->template (sequentially
			       (lambda-protocol 0 #t #f #f)
			       (instruction (enum op push-registers) 1)
			       (instruction (enum op unspecific) 0)
			       (instruction (enum op return) 0))
			     (make-frame #f name 0 #f #f #f))
	  (compile-forms-loop (reverse forms)
			      name
			      #f)))))			;next template

(define (compile-forms-loop forms name next)
  (if (null? forms)
      next
      (compile-forms-loop (cdr forms)
			  name
			  (compile-form (car forms) name next))))

; Compile a single top-level form, returning a template.  NEXT is either #F or
; a template; if it is a template we jump to it after FORM.
; Stack has zero args, no env, template.
  
(define (compile-form form name next)
  (let ((frame (make-frame #f name 0 #t #f #f)))
    (segment->template
      (sequentially
        (lambda-protocol 0 #t #f #f)	; template, no env, no closure
        (push-registers-instruction frame)
	(let ((node (flatten-form (force-node form))))
	  (cond ((define-node? node)
		 (sequentially
		   (compile-definition node frame an-ignore-values-cont)
		   (if next
		       (call-template-inst next #f 0 1 frame)
		       (instruction (enum op values) 0 0))))
		(next
		 (sequentially
  		   (compile-frame node 1 frame an-ignore-values-cont)
		   (call-template-inst next #f 0 1 frame)))
		(else
		 (compile-frame node 1 frame (return-cont #f))))))
      frame)))

(define (call-template-inst template label nargs depth frame)
  (let ((index (literal->index frame template)))
    (using-optional-label (enum op call-template)
			  label
			  (frame-template-index frame)
			  (high-byte index)
			  (low-byte index)
			  nargs)))

(define (template-call template depth frame cont)
  (receive (before depth label after)
      (push-continuation depth frame cont #f #t)
    (sequentially before
		  (call-template-inst template label 0 depth frame)
		  after)))

; Definitions must be treated differently from assignments: we must
; use STORED-OBJECT-SET! instead of SET-GLOBAL! because the SET-GLOBAL!
; instruction traps if an attempt is made to store into an undefined
; location.
;
; Called with a stack depth of one (the template).

(define (compile-definition node frame cont)
  (let* ((form         (node-form node))
	 (name         (cadr form))
	 (arg-cont     (named-register-cont (node-form name)))
	 (out-register (get/allocate-out-register frame cont))
	 (depth 1)) ;; the template
    (deliver-register-value
      (sequentially
        (register-indirect-instruction
          out-register
	  (frame-template-index frame)
	  (binding->index frame
			  (node-ref name 'binding)
			  (node-form name)
			  #f))
        (compile-frame (caddr form) depth frame arg-cont)
        (instruction (enum op stored-object-set!)
                     out-register
                     out-register ; also used for first argument
                     (register-cont-register arg-cont)
                     (enum stob location)
                     location-contents-offset
                     0) ; do not log in current proposal
        (clear-register-cont frame arg-cont))
      out-register frame cont)))
            

(define location-contents-offset
  (cond ((assq 'location stob-data)
	 => (lambda (stuff)
	      (let loop ((slots (cdddr stuff)) (i 0))
		(if (eq? (caar slots) 'contents)
		    i
		    (loop (cdr slots) (+ i 1))))))
	(else
	 (assertion-violation 'location-contents-offset
			      "can't find location data in STOB-DATA"))))

;----------------
; Make a startup procedure from a list of initialization templates.  This
; is only used by the static linker.  RESUMER should be a template that
; returns a procedure that takes 8 arguments (the number the VM passes to
; the startup procedure).

; The length of the argument list needs to be in sync with
; MAKE-USUAL-RESUMER in rts/init.scm, and S48-CALL-STARTUP-PROCEDURE
; in vm/interp/resume.scm.

(define (make-startup-procedure inits resumer)
  (let* ((nargs 8)
	 (frame (make-frame #f		; no parent
			    #f		; no name
			    nargs	; args on stack
			    #t		; keep template
			    #f		; drop environment
			    #f))        ; drop closure
         (cont (register-cont #f #f)))
    (append-templates inits
		      nargs
		      frame
		      (sequentially
		        (template-call resumer
				       (+ nargs 1)	; args + template 
				       frame
				       cont)
		        ; push the original arguments above the template and closure-register
			(let loop ((reg 0) (code empty-segment))
			  (if (= reg nargs)
			      code
			      (loop (+ reg 1) 
			        (sequentially code
			          (instruction (enum op push) reg)))))
			; call the closure with these arguments
			(instruction (enum op tail-call)
			             (register-cont-register cont) 
			             nargs)))))

; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
; and then calls template FINAL on the arguments.

(define (append-templates templates nargs frame final)
  (segment->template
    (sequentially
      (lambda-protocol nargs #t #f #f)	; push template
      (push-registers-instruction frame)
      (reduce (lambda (template seg)
		(sequentially
		  (template-call template
				 (+ nargs 1)		; arguments + template
				 frame
				 an-ignore-values-cont)
		  seg))
	      final
	      templates))
    frame))

(define an-ignore-values-cont (ignore-values-cont #f #f))

